home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / XLisp 2.1e3 ƒ / Sources / xlsubr.c < prev   
Encoding:
C/C++ Source or Header  |  1993-01-20  |  10.2 KB  |  447 lines  |  [TEXT/ttxt]
  1. /* xlsubr - xlisp builtin function support routines */
  2. /*      Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use       */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL k_test,k_tnot,s_eql;
  10. extern LVAL true, s_termio, s_stdin, s_stdout;
  11.  
  12. /* xlsubr - define a builtin function */
  13. #ifdef ANSI
  14. LVAL xlsubr(char *sname, int type, LVAL (*fcn)(void),int offset)
  15. #else
  16. LVAL xlsubr(sname,type,fcn,offset)
  17.   char *sname; int type; LVAL (*fcn)(); int offset;
  18. #endif
  19. {
  20.     LVAL sym;
  21.     sym = xlenter(sname);
  22.     setfunction(sym,cvsubr(fcn,type,offset));
  23.     return (sym);
  24. }
  25.  
  26. /* xlgetkeyarg - get a keyword argument */
  27. int xlgetkeyarg(key,pval)
  28.   LVAL key,*pval;
  29. {
  30.     LVAL *argv=xlargv;
  31.     int argc=xlargc;
  32.     for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
  33.         if (*argv == key) {
  34.             *pval = *++argv;
  35.  
  36.             /* delete the used argument */
  37.             if (argc>0) memcpy(argv-1, argv+1, argc*sizeof(LVAL));
  38.             xlargc -=2;
  39.  
  40.             return (TRUE);
  41.         }
  42.     }
  43.     return (FALSE);
  44. }
  45.  
  46. /* xlgkfixnum - get a fixnum keyword argument */
  47. int xlgkfixnum(key,pval)
  48.   LVAL key,*pval;
  49. {
  50.     if (xlgetkeyarg(key,pval)) {
  51.         if (!fixp(*pval))
  52.             xlbadtype(*pval);
  53.         return (TRUE);
  54.     }
  55.     return (FALSE);
  56. }
  57.  
  58. /* xltest - get the :test or :test-not keyword argument */
  59. VOID xltest(pfcn,ptresult)
  60.   LVAL *pfcn; int *ptresult;
  61. {
  62.     if (xlgetkeyarg(k_test,pfcn))       /* :test */
  63.         *ptresult = TRUE;
  64.     else if (xlgetkeyarg(k_tnot,pfcn))  /* :test-not */
  65.         *ptresult = FALSE;
  66.     else {
  67.         *pfcn = getfunction(s_eql);
  68.         *ptresult = TRUE;
  69.     }
  70. }
  71.  
  72. /* xlgetfile - get a file or stream */
  73. LVAL xlgetfile(outflag)
  74.   int outflag;
  75. {
  76.     LVAL arg;
  77.  
  78.     /* get a file or stream (cons) or nil */
  79.     if (null(arg = xlgetarg()))
  80.         return getvalue(outflag ? s_stdout: s_stdin);
  81.     else if (streamp(arg)) {
  82.         if (getfile(arg) == CLOSED)
  83.             xlfail("file not open");
  84.     }
  85.     else if (arg == true)
  86.         return getvalue(s_termio);
  87.     else if (!ustreamp(arg))
  88.         xlbadtype(arg);
  89.     return arg;
  90. }
  91.  
  92. /* xlgetfname - get a filename */
  93. LVAL xlgetfname()
  94. {
  95.     LVAL name;
  96.  
  97.     /* get the next argument */
  98.     name = xlgetarg();
  99.  
  100.     /* get the filename string */
  101. #ifdef FILETABLE
  102.     if (streamp(name) && getfile(name) > CONSOLE)
  103.         /* "Steal" name from file stream */
  104.         name = cvstring(filetab[getfile(name)].tname);
  105.     else
  106. #endif
  107.     if (symbolp(name))
  108.         name = getpname(name);
  109.     else if (!stringp(name))
  110.         xlbadtype(name);
  111.  
  112.     if (getslength(name) >= FNAMEMAX)
  113.         xlerror("file name too long", name);
  114.  
  115.     /* return the name */
  116.     return (name);
  117. }
  118.  
  119. /* needsextension - check if a filename needs an extension */
  120. int needsextension(name)
  121.   char *name;
  122. {
  123.     char *p;
  124.  
  125. #ifdef NO_EXTENSIONS
  126.     return (FALSE);
  127. #else
  128.     /* check for an extension */
  129.     for (p = &name[strlen(name)]; --p >= &name[0]; )
  130.         if (*p == '.')
  131.             return (FALSE);
  132.         else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
  133.             return (TRUE);
  134.  
  135.     /* no extension found */
  136.     return (TRUE);
  137. #endif
  138. }
  139.  
  140. /* xlbadtype - report a "bad argument type" error */
  141. LVAL xlbadtype(arg)
  142.   LVAL arg;
  143. {
  144.     return xlerror("bad argument type",arg);
  145. }
  146.  
  147. /* xltoofew - report a "too few arguments" error */
  148. LVAL xltoofew()
  149. {
  150.     xlfail("too few arguments");
  151.     return (NIL);   /* never returns */
  152. }
  153.  
  154. /* xltoomany - report a "too many arguments" error */
  155. VOID xltoomany()
  156. {
  157.     xlfail("too many arguments");
  158. }
  159.  
  160. /* xltoolong - report a "too long to process" error */
  161. VOID xltoolong()
  162. {
  163.     xlfail("too long to process");
  164. }
  165.  
  166. /* xlnoassign - report a "can't assign/bind to constant" error */
  167. VOID xlnoassign(arg)
  168.    LVAL arg;
  169. {
  170.     xlerror("can't assign/bind to constant", arg);
  171. }
  172.  
  173. #ifdef COMPLX
  174. /* compare floating point for eql and equal */
  175. /* This is by Tom Almy */
  176. #ifdef ANSI
  177. static int NEAR comparecomplex(LVAL arg1, LVAL arg2)
  178. #else
  179. LOCAL int comparecomplex(arg1, arg2)
  180. LVAL arg1, arg2;
  181. #endif
  182. {
  183.     LVAL r1=getelement(arg1,0), r2=getelement(arg2,0);
  184.     LVAL i1=getelement(arg1,1), i2=getelement(arg2,1);
  185.  
  186.     if (ntype(r1) != ntype(r2)) return FALSE;
  187.     else if (ntype(r1) == FIXNUM)
  188.         return (getfixnum(r1)==getfixnum(r2)&&
  189.                 getfixnum(i1)==getfixnum(i2));
  190.     else
  191.         return (getflonum(r1)==getflonum(r2)&&
  192.                 getflonum(i1)==getflonum(i2));
  193. }
  194.  
  195. #endif
  196.  
  197. /* eql - internal eql function */
  198. int eql(arg1,arg2)
  199.   LVAL arg1,arg2;
  200. {
  201.     /* compare the arguments */
  202.     if (arg1 == arg2)
  203.         return (TRUE);
  204.     else if (arg1 != NIL) {
  205.         switch (ntype(arg1)) {
  206.         case FIXNUM:
  207.             return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  208.         case FLONUM:
  209.             return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  210. #ifdef COMPLX
  211.         case COMPLEX:
  212.             return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE);
  213. #endif
  214.         default:
  215.             return (FALSE);
  216.         }
  217.     }
  218.     else
  219.         return (FALSE);
  220. }
  221.  
  222. #ifdef ANSI
  223. static int NEAR stringcmp(LVAL arg1, LVAL arg2)
  224. #else
  225. LOCAL stringcmp(arg1, arg2)         /* compare two strings for equal */
  226. LVAL arg1, arg2;                    /* Written by TAA. Compares strings */
  227.                                     /* with embedded nulls */
  228. #endif
  229. {
  230.     char FAR *s1 = getstring(arg1), FAR *s2 = getstring(arg2);
  231.     unsigned l = getslength(arg1);
  232.  
  233.     if (l != getslength(arg2)) return FALSE;
  234.  
  235.     while (l-- > 0) if (*s1++ != *s2++) return FALSE;
  236.  
  237.     return TRUE;
  238. }
  239.  
  240. /* equal- internal equal function */
  241. int equal(arg1,arg2)
  242.   LVAL arg1,arg2;
  243. {
  244.     /* compare the arguments */
  245. isItEqual:  /* turn tail recursion into iteration */
  246.     if (arg1 == arg2)
  247.         return (TRUE);
  248.     else if (arg1 != NIL) {
  249.         switch (ntype(arg1)) {
  250.         case FIXNUM:
  251.             return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  252.         case FLONUM:
  253.             return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  254. #ifdef COMPLX
  255.         case COMPLEX:
  256.             return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE);
  257. #endif
  258.         case STRING:
  259.             return (stringp(arg2) ? stringcmp(arg1,arg2) : FALSE); /* TAA MOD */
  260.         case CONS:  /* TAA MOD turns tail recursion into iteration */
  261.                     /* Not only is this faster, but greatly reduces chance */
  262.                     /* of stack overflow */
  263.             if (consp(arg2) && equal(car(arg1),car(arg2))) {
  264.                 arg1 = cdr(arg1);
  265.                 arg2 = cdr(arg2);
  266.                 goto isItEqual;
  267.             }
  268.             return FALSE;
  269.         default:
  270.             return (FALSE);
  271.         }
  272.     }
  273.     else
  274.         return (FALSE);
  275. }
  276.  
  277.  
  278. #ifdef KEYARG
  279. /* TAA Addition */
  280. /* xlkey - get the :key keyword argument */
  281. extern LVAL k_key;
  282.  
  283. LVAL xlkey()
  284. {
  285.     LVAL kfcn;
  286.  
  287.     if (xlgetkeyarg(k_key,&kfcn)) return kfcn;
  288.     return NIL;
  289. }
  290.  
  291. /* xlapp1 - apply a function of a single argument */
  292. LVAL xlapp1(fun,arg)
  293.   LVAL fun,arg;
  294. {
  295.     FRAMEP newfp;
  296.  
  297.     /* create the new call frame */
  298.     newfp = xlsp;
  299.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  300.     pusharg(fun);
  301.     pusharg(cvfixnum((FIXTYPE)1));
  302.     pusharg(arg);
  303.     xlfp = newfp;
  304.  
  305.     /* return the result of applying the function */
  306.     return xlapply(1);
  307.  
  308. }
  309.  
  310.  
  311. /* dotest1 - call a test function with one argument */
  312. int dotest1(arg,fun,kfun)
  313.   LVAL arg,fun,kfun;
  314. {
  315.     FRAMEP newfp;
  316.  
  317.     if (kfun != NIL) arg = xlapp1(kfun,arg);
  318.  
  319.     /* create the new call frame */
  320.     newfp = xlsp;
  321.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  322.     pusharg(fun);
  323.     pusharg(cvfixnum((FIXTYPE)1));
  324.     pusharg(arg);
  325.     xlfp = newfp;
  326.  
  327.     /* return the result of applying the test function */
  328.     return (xlapply(1) != NIL);
  329.  
  330. }
  331.  
  332. /* dotest2 - call a test function with two arguments */
  333. int dotest2(arg1,arg2,fun,kfun)
  334.   LVAL arg1,arg2,fun,kfun;
  335. {
  336.     FRAMEP newfp;
  337.  
  338.     if (kfun != NIL) arg2 = xlapp1(kfun,arg2);
  339.  
  340.     /* Speedup for default case TAA MOD */
  341.     if (fun == getfunction(s_eql))
  342.         return (eql(arg1,arg2));
  343.  
  344.     /* create the new call frame */
  345.     newfp = xlsp;
  346.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  347.     pusharg(fun);
  348.     pusharg(cvfixnum((FIXTYPE)2));
  349.     pusharg(arg1);
  350.     pusharg(arg2);
  351.     xlfp = newfp;
  352.  
  353.     /* return the result of applying the test function */
  354.     return (xlapply(2) != NIL);
  355.  
  356. }
  357.  
  358. /* dotest2s - call a test function with two arguments, symmetrical */
  359. int dotest2s(arg1,arg2,fun,kfun)
  360.   LVAL arg1,arg2,fun,kfun;
  361. {
  362.     FRAMEP newfp;
  363.  
  364.     if (kfun != NIL) {
  365.         arg1 = xlapp1(kfun,arg1);
  366.         arg2 = xlapp1(kfun,arg2);
  367.     }
  368.  
  369.     /* Speedup for default case TAA MOD */
  370.     if (fun == getfunction(s_eql))
  371.         return (eql(arg1,arg2));
  372.  
  373.     /* create the new call frame */
  374.     newfp = xlsp;
  375.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  376.     pusharg(fun);
  377.     pusharg(cvfixnum((FIXTYPE)2));
  378.     pusharg(arg1);
  379.     pusharg(arg2);
  380.     xlfp = newfp;
  381.  
  382.     /* return the result of applying the test function */
  383.     return (xlapply(2) != NIL);
  384.  
  385. }
  386.  
  387. #else
  388. /* dotest1 - call a test function with one argument */
  389. int dotest1(arg,fun)
  390.   LVAL arg,fun;
  391. {
  392.     FRAMEP newfp;
  393.  
  394.     /* create the new call frame */
  395.     newfp = xlsp;
  396.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  397.     pusharg(fun);
  398.     pusharg(cvfixnum((FIXTYPE)1));
  399.     pusharg(arg);
  400.     xlfp = newfp;
  401.  
  402.     /* return the result of applying the test function */
  403.     return (xlapply(1) != NIL);
  404.  
  405. }
  406.  
  407. /* dotest2 - call a test function with two arguments */
  408. int dotest2(arg1,arg2,fun)
  409.   LVAL arg1,arg2,fun;
  410. {
  411.     FRAMEP newfp;
  412.  
  413.     /* Speedup for default case TAA MOD */
  414.     if (fun == getfunction(s_eql))
  415.         return (eql(arg1,arg2));
  416.  
  417.     /* create the new call frame */
  418.     newfp = xlsp;
  419.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  420.     pusharg(fun);
  421.     pusharg(cvfixnum((FIXTYPE)2));
  422.     pusharg(arg1);
  423.     pusharg(arg2);
  424.     xlfp = newfp;
  425.  
  426.     /* return the result of applying the test function */
  427.     return (xlapply(2) != NIL);
  428.  
  429. }
  430.  
  431. #endif
  432.  
  433. #ifdef COMPLX
  434. /* return value of a number coerced to a FLOTYPE */
  435. FLOTYPE makefloat(x)
  436.      LVAL x;
  437. {
  438.     if (fixp(x)) return ((FLOTYPE) getfixnum(x));
  439.     else if (floatp(x)) return getflonum(x);
  440. #ifdef RATIOS
  441.     else if (ratiop(x)) return (getnumer(x)/(FLOTYPE)getdenom(x));
  442. #endif
  443.     xlerror("not a number", x);
  444.     return 0.0; /* never reached */
  445. }
  446. #endif
  447.